perm filename WLDMOD.SAI[HAL,HE]9 blob sn#223553 filedate 1976-07-05 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00021 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00003 00002	
C00004 00003	SIMPLE PROCEDURE STITINI
C00005 00004	! fluent_rec,fluent_fact
C00006 00005	! csplit, stmchk, is_undef_sym_item
C00008 00006	! world assignment:  xxxwld, wldasg (lpbasg, parasg)
C00014 00007	! check_guards
C00015 00008	! fluent_check,mergein
C00017 00009	! cpattl
C00019 00010	! asrtit & denyit
C00022 00011	! new_exprn, stmake, new_stmnt, new_gassign, new_alsodo
C00027 00012	! younger,afxdget
C00030 00013	! controllable
C00033 00014	! dexprset, domove
C00039 00015	! do_affix, do_affix_stmnt, do_unfix
C00044 00016	! blockdo & sttblk, blkopdo
C00047 00017	! Cobdo
C00049 00018	! loopbdo
C00050 00019	! statement interpreter: stinterp (owdo, iwcopy)
C00057 00020	ifcr false thenc ! proc_form interpreter:  apfrm, apfrm2
C00059 00021	! test program
C00060 ENDMK
C⊗;

IFCR ¬DECLARATION(EXTENDED_COMPILATION) THENC
ENTRY;

BEGIN "WLDMOD"
IFCR ¬DECLARATION(CREFFING) THENC DEFINE CREFFING = FALSE;ENDC
IFCR ¬ CREFFING THENC
REQUIRE "HALREQ.HDR[HAL,HE]" SOURCE_FILE;
ENDC
REDEFINE $$PRGID "[]" = ["WLDMOD"];
ENDC

REQUIRE 300 SYSTEM_PDL;

INTEGER STITRC;

RPTR(SPECVAL) VNEWTRANS;

PROCEDURE VNEWINI;
	BEGIN
	VNEWTRANS←NEW_RECORD(SPECVAL);
	SPECVAL:TYPE[VNEWTRANS]←TRANS_DTYPE;
	END;

REQUIRE VNEWINI INITIALIZATION;

RPTR(BLOCK) CURBLK; ! id of current block in stinterp;

SIMPLE PROCEDURE STITINI;
	BEGIN
	OUTSTR("
SET TRACE OPTIONS FOR STINTERP:
'1 -- print ""statement"" type
'2 -- print ""statement"" record
type in one fhq octal number:");
	STITRC←CVO(INCHWL);
	END;

! fluent_rec,fluent_fact;

RPTR(FLUENT) FLUENT_REC; ! set by fluent_fact;
BOOLEAN PROCEDURE FLUENT_FACT(RPTR(FACT) F);
	BEGIN
	RANY PTN;
	PTN←FACT:PATT[F];
	IF RECLEN(PTN)≠2 THEN RETURN(FALSE);
	START_CODE "FLFSTC"
	LABEL XXX,XXX0;
	SKIPE	1,PTN;
	SKIPN	1,1(1);
	JRST	XXX;
	TLC	1,REC_CODE;
	TLNE	1,(PROCB+ARY2B+ITEMB+'3740);
	JRST	XXX0; ! false if first isn't ref(record);
	HRRZ	1,(1); ! point at record;
	MOVEM   1,FLUENT_REC;
	HRRZ	1,(1); ! point at record type;
	CAIN	1,FLUENT;
XXX0:	TDZA	1,1;
	MOVEI	1,1;
XXX:	END;
	
	END;
! csplit, stmchk, is_undef_sym_item;

SIMPLE ITEMVAR PROCEDURE CSPLIT(ITEMVAR IW;BOOLEAN NEWFG(TRUE));
	RETURN(IF NEWFG THEN NEWWLD ELSE IW);

! be sure S is a statement;

RPTR(STMNT) PROCEDURE STMCHK(RANY S);
	RETURN(CHKREC(S,LOC(STMNT)));

! world assignment:  xxxwld, wldasg (lpbasg, parasg);

SIMPLE ITEMVAR PROCEDURE XXXWLD(ITEMVAR INW;BOOLEAN CLANY(FALSE));
	BEGIN
        ! Makes a copy of the input world and returns it.  If CLANY
        is TRUE, then the "clear" field of the new world is set to
        ANY.  Otherwise, it is copied from the old world.;
	ITEMVAR OUW;
	OUW←NEWWLD;
	CLEAR[WLDINX(OUW)]←IF CLANY THEN ANY ELSE CLEAR[WLDINX(INW)];
	COPY_ALERTS(INW,OUW);
	RETURN(OUW);
	END;

INTERNAL RECURSIVE PROCEDURE WLDASG(RPTR(STMNT) S;
		ITEMVAR IW;REFERENCE ITEMVAR OW;REFERENCE BOOLEAN NFLAG);
	BEGIN
        !  Assigns worlds to statements associated with the statement
        S.  If NFLAG is true, then something or other special
        happens. (This flag is used to avoid assigning separate 
	worlds to successive assignment statements).
	No longer makes the variable list for blocks.
	;

	LABEL XIT;
	RANY SS;
	INTEGER ST;
	RCELL C;
	BOOLEAN NF;

	RECPROC LPBASG(RPTR(STMNT) SS);
		BEGIN
		!  Handles the special case of a loop body;
		ITEMVAR IWW,WW;
		IF SS = RNULL THEN RETURN;
		NF←TRUE;
		IWW←XXXWLD(IW,TRUE);
		WW←PREP_ALERT(IWW);
		CLEAR[WLDINX(IWW)]←WW;
		WLDASG(SS,IWW,OW,NF);
		OW←XXXWLD(IW);
		END;

	RECPROC PARASG(RCELL C);
		BEGIN
                ! CDRs down a list of statements that are meant to be
                parallel in execution, doing the world assignments.
                Assigns a world to the end as well;
		WHILE C≠NULL_RECORD DO
			BEGIN
			NF←TRUE;
			WLDASG(STMCHK(CELL:CAR[C]),XXXWLD(IW,TRUE),OW,NF);
			C←CELL:CDR[C];
			END;
		OW←XXXWLD(IW);
		END;

	SS←STMNT:SEMANTICS[S];
	ST←RECTYPE(SS);
	STMNT:IW[S]←IW;
	IF ST=0 ∨ ST =LOC(COMMNT) ∨ ST=LOC(PAUSE) THEN
		BEGIN
		OW←STMNT:OW[S]←IW;
		RETURN;
		END;
	IF ST=LOC(ASSERT)∨ST=LOC(DENY) THEN
		BEGIN
		IF ASSERT:WLD[SS]≠ANY THEN
			BEGIN
			OW←IW;
			END
		ELSE
			BEGIN
			OW←IF NFLAG THEN XXXWLD(IW) ELSE IW;
			ASSERT:WLD[SS]←OW;
			NFLAG←FALSE;
			END;
		STMNT:OW[S]←OW;
		RETURN;
		END
	ELSE IF ST=LOC(ASSIGNMENT)∨ST=LOC(GASSIGN) THEN
		BEGIN
		OW←STMNT:OW[S]←IF NFLAG THEN XXXWLD(IW) ELSE IW;
		NFLAG←FALSE;
		RETURN;
		END
	ELSE 
		NFLAG←TRUE;

	NF←TRUE;

	IF ST=LOC(BLOCK) THEN
		BEGIN "blkasg"
		RPTR(BLOCK) B;
		B←SS;
		C←BLOCK:CODE[B];
		OW←IW;
		WHILE C≠NULL_RECORD DO
			BEGIN
			SS←CELL:CAR[C];
			ST←RECTYPE(SS);
			IF ST=LOC(PVL)∨ST=LOC(DBD) THEN
				BEGIN
				END
			ELSE IF ST=LOC(VARIABLE) THEN
				BEGIN
				END
			ELSE IF ST=LOC(STMNT) THEN
				BEGIN "sasa"
				WLDASG(SS,OW,OW,NF);
				END;	
			C←CELL:CDR[C];
			END;
		! **** perhaps will want to give blocks their own variables ****;
		END
	ELSE IF ST=LOC(COBLOCK) THEN
		BEGIN
		PARASG(COBLOCK:CODE[SS]);
		END
	ELSE IF ST=LOC(FORR) THEN
		LPBASG(FORR:BODY[SS])
	ELSE IF ST=LOC(WHIL) THEN
		LPBASG(WHIL:BODY[SS])
	ELSE IF ST=LOC(IFF) THEN
		BEGIN
		NF←TRUE;
		WLDASG(IFF:THN[SS],XXXWLD(IW,TRUE),OW,NF);
		NF←TRUE;
		WLDASG(IFF:ELS[SS],XXXWLD(IW,TRUE),OW,NF);
		OW←XXXWLD(IW);
		END
	ELSE IF ST=LOC(NW) THEN
		BEGIN
		NFLAG←FALSE;
		OW←NW:WLD[SS];
		IF OW=ANY THEN
			OW←XXXWLD(IW)
		ELSE
			BEGIN
			CLEAR[WLDINX(OW,-1)]←CLEAR[WLDINX(IW)];
			COPY_ALERTS(IW,OW);
			END;
		END
	ELSE IF ST=LOC(PROG) THEN
		BEGIN
		! **** Not sure what to do here with NFLAG & NF ****;
		WLDASG(PROG:CODE[SS],XXXWLD(IW,TRUE),OW,NF);
		END
	ELSE IF ST=LOC(CMON) THEN
		BEGIN  !  Coded by RF;
		WLDASG(CMON:CONCLUSION[SS],XXXWLD(IW,TRUE),OW,NF);
		END
	ELSE
		OW←XXXWLD(IW);
	STMNT:OW[S]←OW;
XIT:	END;

! check_guards;

PROCEDURE CHECK_GUARDS(ITEMVAR IW,OW);
	BEGIN
	RPTR(FACT) F;
	INTEGER OWX;
	ITEMVAR GW,WW;
	∀ WW | ALERT_ORDER⊗IW≡WW DO
		BEGIN
		GW←GUARD[WLDINX(WW)];
		IF GW=ANY THEN CONTINUE;
		∀ | GEN_FACTS(F,GW) DO
			BEGIN
			IF ¬TSTWIX(F,OWX) THEN
				BEGIN
				INTEGER CTL;
				CTL←GETPRINT;
				SETPRINT(NULL,"C");
				PRINT(CRLF&"WARNING: ");
				RECPRN(FACT:PATT[F]);
				PRINT(" WAS ASSUMED TO BE TRUE, BUT MAY NOT BE"
					&CRLF);
				IF CTL="F" ∨ CTL="N" ∨ CTL="S" THEN
					SETPRINT(NULL,"I");
				END;
			END;
		END;
	END;

! fluent_check,mergein;

PROCEDURE FLUENT_CHECK(ITEMVAR W;RPTR(FACT) F);
	BEGIN
	INTEGER WX;
	WX←WLDINX(W);
	IF TSTWIX(F,WX) ∧ FLUENT_FACT(F) THEN 
		BEGIN
		! FLUENT_REC contains the fluent for F;
		CLRWLD(F,WX); ! delete it from world;
		IF ¬PMATCH(W,FLUENT:RETRPATT[FLUENT_REC],TRUE) THEN
			SETWLD(F,WX); ! this was the only one;
		END;
	FLUENT_REC←NULL_RECORD; ! sheer paranoia;
	END;

PROCEDURE MERGEIN(ITEMVAR IW,OW,IIW);
	BEGIN
	! OW ← ((OW∪IW) - (IIW-(OW∩IW)))-INCOMPATIBLE_FLUENTS;
	RPTR(FACT) F;
	INTEGER IWX,OWX,IIWX;
	IWX←WLDINX(IW);OWX←WLDINX(OW);IIWX←WLDINX(IIW);
	∀ | GEN_FACTS(F,OW) DO
		BEGIN
		IF ¬TSTWIX(F,IWX)∧TSTWIX(F,IIWX) THEN
			CLRWLD(F,OWX);
		END;
	∀ | GEN_FACTS(F,IW) DO
		BEGIN
		! RF - Removed extraneous ELSE before the IF;
		IF ¬TSTWIX(F,OWX)∧TSTWIX(F,IIWX) THEN
			SETWLD(F,OWX);
		END;
	END;
! cpattl;

LIST PROCEDURE CPATTL(RCELL C;ITEMVAR WLD;REFERENCE RCELL BL);
	BEGIN
	RANY V;
	ITEMVAR IV;
	INTEGER VTYP;
	LIST PL;
	BL←NULL_RECORD;
	PL←NIL;
	WHILE C≠NULL_RECORD DO
		BEGIN "CLOOP"
		V←CELL:CAR[C];
		VTYP←RECTYPE(V);
		IF VTYP=LOC(NOMV) THEN
			BEGIN
			! fetch nominal value;
			V←EVALEXPR(V,WLD);
			END
		ELSE IF VTYP=LOC(BINDV) THEN
			BEGIN
			BL←CONS(V,BL);
			IV←\(BINDV:RESULT[V])[1];
			∂(IV,INTEGER)←∂(IV,INTEGER) LOR BINDB;
			! **** BECAUSE OF A SAIL LOSSAGE *****;
			PL[∞+1]←IV;
			CONTINUE "CLOOP";
			END
		ELSE IF VTYP≠LOC(VARIABLE) THEN 
			USERERR(1,1,"CPATTL DOESN'T EXPECT AN ELEMENT OF TYPE "
					&CVRTS(VTYP));
		PL←PL&\($ V);
		C←CELL:CDR[C];
		END;
	RETURN(PL);
	END;
! asrtit & denyit;

INTERNAL PROCEDURE ASRTIT(RPTR(AFACT,SFACT) F;ITEMVAR IW,OW);
	BEGIN
	RCELL CC;
	IF RECTYPE(F)=LOC(AFACT) THEN
		BEGIN
		RPTR(EXPRN,VARIABLE) L;
		L←AFACT:LEFT[F];
		IF RECTYPE(L)≠LOC(VARIABLE)∨AFACT:RELN[F]≠0 THEN
			BEGIN
			INTEGER CTL;
			CTL←GETPRINT;
			SETPRINT(NULL,"C");
			PRINT(CRLF);
			ALPRIN(F);
			IF CTL="F" ∨ CTL="N" ∨ CTL="S" THEN SETPRINT(NULL,"I");
			USERERR(1,1," asrtit given an afact it cannot handle"&crlf);
			RETURN;
			END
		ELSE
			VCHANGE(L,EVALEXPR(AFACT:RIGHT[F],IW),OW);
		END
	ELSE IF RECTYPE(F)=LOC(SFACT) THEN
		BEGIN "SASSERT"
		LPASRT(OW,CPATTL(SFACT:PATT[F],IW,CC));
		IF CC≠NULL_RECORD THEN 
			USERERR(1,1,"BINDING ASSERTIT??");
		END
	ELSE
		USERERR(1,1,"ASRTIT CALLED WITH FUNNY FACT");
	END;

INTERNAL PROCEDURE DENYIT(RPTR(SFACT,AFACT) F;ITEMVAR IW,OW);
	BEGIN
	RANY CC;
	IF RECTYPE(F)=LOC(AFACT) THEN
		BEGIN
		RPTR(EXPRN,VARIABLE) L;
		L←AFACT:LEFT[F];
		IF RECTYPE(L)≠LOC(VARIABLE)∨AFACT:RELN[F]≠0 THEN
			BEGIN
			INTEGER CTL;
			CTL←GETPRINT;
			SETPRINT(NULL,"C");
			PRINT(CRLF);
			ALPRIN(F);
			IF CTL="F" ∨ CTL="N" ∨ CTL="S" THEN SETPRINT(NULL,"I");
			USERERR(1,1," denyit given an afact it cannot handle"&crlf);
			RETURN;
			END
		ELSE
			BEGIN
			IF EXPEQV(EVALEXPR(L,IW),EVALEXPR(AFACT:RIGHT[F],IW)) THEN
				INVALIDATE(L,OW);
			END;
			
		END
	ELSE IF RECTYPE(F)=LOC(SFACT) THEN
		BEGIN "SDENY"
		LPDENY(OW,CPATTL(SFACT:PATT[F],IW,CC));
		IF CC≠NULL_RECORD THEN
			USERERR(1,1," binding denyit?? ");
		END
	ELSE
		USERERR(1,1,"DENYIT CALLED WITH FUNNY FACT");
	END;

! new_exprn, stmake, new_stmnt, new_gassign, new_alsodo;

INTERNAL RPTR(EXPRN) PROCEDURE NEW_EXPRN(INTEGER DT,OP;RCELL ARGS);
	BEGIN
	RPTR(EXPRN) E;
	E←NEW_RECORD(EXPRN);
	EXPRN:DATATYPE[E]←DT;
	EXPRN:OP[E]←OP;
	EXPRN:ARGS[E]←ARGS;
	RETURN(E);
	END;

INTERNAL RPTR(STMNT) PROCEDURE STMAKE(RSSS SEM(NULL_RECORD));
	BEGIN
	RPTR(STMNT) S;
	S←NEW_RECORD(STMNT);
	STMNT:SEMANTICS[S]←SEM;
	STMNT:ID[S]←NEW(S);
	RETURN(S);
	END;

INTERNAL RPTR(STMNT) PROCEDURE NEW_STMNT(ITEMVAR IW,OW; RSSS SEM);
	BEGIN
	RPTR(STMNT) S;
	S←STMAKE(SEM);
	STMNT:IW[S]←IW;
	STMNT:OW[S]←OW;
	RETURN(S);
	END;

INTERNAL RPTR(GASSIGN) PROCEDURE NEW_GASSIGN(RVAR V;INTEGER OP;
					RPTR(CALCULATOR) C);
	BEGIN
	RPTR(GASSIGN) GA;
	GA←NEW_RECORD(GASSIGN);
	GASSIGN:VAR[GA]←V;
	GASSIGN:OP[GA]←OP;
	GASSIGN:CLC[GA]←C;
	RETURN(GA);
	END;

INTERNAL RPTR(ALSODO) PROCEDURE NEW_ALSODO(RVAR V;INTEGER OP;
					RPTR(CHANGER) C);
	BEGIN
	RPTR(ALSODO) ADO;
	ADO←NEW_RECORD(ALSODO);
	ALSODO:VAR[ADO]←V;
	ALSODO:OP[ADO]←OP;
	ALSODO:CHG[ADO]←C;
	RETURN(ADO);
	END;
! younger,afxdget;

RPTR(VARIABLE) PROCEDURE YOUNGER(RPTR(VARIABLE) V1,V2);
	BEGIN
	RPTR(BLOCK) B1,B2;
	B1←VARIABLE:BLK[V1];B2←VARIABLE:BLK[V2];
	IF B1=NULL_RECORD THEN RETURN(V2);
	IF B2=NULL_RECORD THEN RETURN(V1);
	DO	BEGIN
		IF B1=B2 THEN RETURN(V1);
		B1←BLOCK:PARENT[B1];
		END UNTIL B1=NULL_RECORD;
	B1←VARIABLE:BLK[V1];
	DO	BEGIN
		IF B1=B2 THEN RETURN(V2);
		B2←BLOCK:PARENT[B2];
		END UNTIL B2=NULL_RECORD;
	BUG("CANNOT TELL WHICH IS YOUNGER");
	RETURN(V1); ! arbitrary;
	END;

RCELL AFXDLIS;

RPTR(AFXDATA) PROCEDURE AFXDGET(RVAR A,B;RPTR(VARIABLE,EXPRN) TT;BOOLEAN MAKENEW);
	BEGIN
	RCELL C;
	RVAR T;
	RPTR(AFXDATA) AD;
	IF RECTYPE(TT)=LOC(EXPRN) THEN
		BEGIN
		IF EXPRN:OP[TT]≠TINVRT_OP THEN
			BUG("FUNNY EXPRESSION TO AFXGET")
		ELSE
			T←CHKREC(CELL:CAR[EXPRN:ARGS[TT]],LOC(VARIABLE));
		END
	ELSE
		T←TT;
	IF VARIABLE:DATATYPE[T]≠TRANS_DTYPE THEN
		BUG("FUNNY BY VARIABLE TO AFXDGET");
	C←AFXDLIS;
	WHILE C≠NULL_RECORD DO
		BEGIN
		AD←LLOP(C);
		IF AFXDATA:A[AD]=A∧AFXDATA:B[AD]=B∧AFXDATA:T[AD]=T THEN
			RETURN(AD);
		END;
	IF ¬MAKENEW∨TT≠T THEN 
		BUG("COULDN'T FIND AFX DATA");
	AD←NEW_RECORD(AFXDATA);
	AFXDATA:A[AD]←A;AFXDATA:B[AD]←B;AFXDATA:T[AD]←T;
	AFXDATA:YOUNGEST[AD]←YOUNGER(A,YOUNGER(B,T));
	RETURN(CONSON(AD,AFXDLIS));
	END;

! controllable;

BOOLEAN RECPROC CONTROLLABLE(ITEMVAR WLD;RVAR A;
			     REFERENCE RVAR CF;REFERENCE REXPR BYEXP;
			     REFERENCE SET SEEN);
	BEGIN
	RVAR N,RGF;
	RPTR(VARIABLE,EXPRN) BYE;
	RPTR(EXPRN) E;

	IF A=BARM ∨ A=YARM THEN
		BEGIN
		BYEXP←NULL_RECORD;CF←A;
		RETURN(TRUE);
		END;
	PUT VARIABLE:NAME[A] IN SEEN;
	∀ | LPMATCH(WLD,\(AFFIXED,$ A,BIND N,BIND BYE,BIND RGF)) DO
		BEGIN
		IF VARIABLE:NAME[N] ε SEEN THEN CONTINUE;
		IF CONTROLLABLE(WLD,N,CF,E,SEEN) THEN
			BEGIN
			IF E=NULL_RECORD THEN
				BYEXP←BYE
			ELSE
				BYEXP←NEW_EXPRN(TRANS_DTYPE,
						TTMUL_OP,LIST2(E,BYE));
			RETURN(TRUE);
			END;
		END;
	RETURN(FALSE);
	END;

! dexprset, domove;

PROCEDURE DEXPRSET(RPTR(DEXPR) DE;REXPR DX,TX;
				  INTEGER DATATYPE;
				  ITEMVAR WLD);
	BEGIN
	! DX is destination expression from MOVE statement.
	  TX is correction from affixment structure.
	  Actual destination should be DE*inv(TX).
	  Computes planning value in WLD & puts away in
	  VAL[DE]. Also, puts planning value away into VAR[DE]
	  via a call to VCHANGE.
	;
	IF TX≠NULL_RECORD THEN
		BEGIN
		IF DATATYPE=FRAME_DTYPE THEN
			DX ← NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
				LIST2(DX,INVSIMP(NEW_EXPRN(TRANS_DTYPE,TINVRT_OP,
					           CONS(TX,NULL_RECORD))) ))
		ELSE
			BUG("DEXPRTYPE CANNOT HANDLE DATATYPE ");
		END;
	IF RECTYPE(DX)≠LOC(VARIABLE) THEN
		BEGIN
		IF DEXPR:TMPVAR[DE]≠NULL_RECORD THEN
			BEGIN
			IF VARIABLE:DATATYPE[DEXPR:TMPVAR[DE]]≠DATATYPE THEN
				BUG("WARNING: INCOMPATIBLE TYPES IN USE OF TEMP");
			END
		ELSE
			DEXPR:TMPVAR[DE]←NEW_VAR(NEW(NULL_RECORD),DATATYPE,CURBLK);
		DEXPR:VAR[DE]←DEXPR:TMPVAR[DE];
		DEXPR:EXPN[DE]←DX;
		END
	ELSE
		BEGIN
		DEXPR:VAR[DE]←DEXPR:EXPN[DE]←DX;
		END;
	DEXPR:VAL[DE]←EVALEXPR(DX,WLD);
	VCHANGE(DEXPR:VAR[DE],DEXPR:VAL[DE],WLD);
	END;

RECURSIVE PROCEDURE DOMOVE(RPTR(STMNT) S);
	BEGIN			
	RPTR(EXPRN) E;
	SET SEEN;
	RCELL C;
	RANY ONM;
	RPTR(MOVE$) MS;
	INTEGER DT;
	ITEMVAR IW,OW;
		
	IW←STMNT:IW[S];OW←STMNT:OW[S];
	CPYWLD(IW,OW);
	MS ← STMNT:SEMANTICS[S];   !  Added by RF;
	SEEN←PHI;
	IF MOVE$:WHAT[MS]=YHAND ∨ MOVE$:WHAT[MS]=BHAND THEN
		BEGIN ! OK, Ray, you win.  But this is a kluge;
		E ← NULL_RECORD;
		DT←SVAL_DTYPE;
		MOVE$:CF[MS] ← MOVE$:WHAT[MS];
		END
	ELSE 
		BEGIN
		DT←FRAME_DTYPE;
		IF ¬CONTROLLABLE(OW,MOVE$:WHAT[MS],MOVE$:CF[MS],E,SEEN) THEN
			BUG("MOVE MUST HAVE A CONTROLLABLE FRAME");
		END;
	DEXPRSET(MOVE$:DEXP[MS],MOVE$:DEST[MS],E,DT,OW);
	VCHANGE(MOVE$:CF[MS],DEXPR:VAL[MOVE$:DEXP[MS]],OW);
	C←MOVE$:CLAUSES[MS];
	WHILE C≠NULL_RECORD DO
		BEGIN
		RANY X;INTEGER RT;
		X←LLOP(C);
		IF (RT←RECTYPE(X))=LOCATION(CMON) THEN
			BEGIN
			STINTERP(STMCHK(CMON:CONCLUSION[X]));
			ANDWLD(STMNT:OW[X],OW,OW);
			END
		ELSE IF RT=LOCATION(VIA) THEN
			BEGIN
			DEXPRSET(VIA:ACTPLACE[X],VIA:PLACE[X],E,DT,OW);
			END;
		END;
	END;

RECURSIVE PROCEDURE DOOPERATE(RPTR(STMNT) S);
	BEGIN	  ! Modified by RF from DOMOVE;
	RPTR(EXPRN) E;
	SET SEEN;
	RCELL C;
	RANY ONM;
	RPTR(OPERATE) MS;
	INTEGER DT;
	ITEMVAR IW,OW;
		
	IW←STMNT:IW[S];OW←STMNT:OW[S];
	CPYWLD(IW,OW);
	MS ← STMNT:SEMANTICS[S];   !  Added by RF;
	SEEN←PHI;
	IF OPERATE:WHAT[MS]=YHAND ∨ OPERATE:WHAT[MS]=BHAND THEN
		BEGIN ! OK, Ray, you win.  But this is a kluge;
		E ← NULL_RECORD;
		DT←SVAL_DTYPE;
		OPERATE:CF[MS] ← OPERATE:WHAT[MS];
		END
	ELSE 	BUG("OPERATE MUST USE A HAND");
	DEXPRSET(OPERATE:DEXP[MS],OPERATE:DEST[MS],E,DT,OW);
	VCHANGE(OPERATE:CF[MS],DEXPR:VAL[OPERATE:DEXP[MS]],OW);
	C←OPERATE:CLAUSES[MS];
	WHILE C≠NULL_RECORD DO
		BEGIN
		RANY X;INTEGER RT;
		X←LLOP(C);
		IF (RT←RECTYPE(X))=LOCATION(CMON) THEN
			BEGIN
			STINTERP(STMCHK(CMON:CONCLUSION[X]));
			ANDWLD(STMNT:OW[X],OW,OW);
			END
		ELSE IF RT=LOCATION(VIA) THEN
			BEGIN
			DEXPRSET(VIA:ACTPLACE[X],VIA:PLACE[X],E,DT,OW);
			END;
		END;
	END;

! do_affix, do_affix_stmnt, do_unfix;

INTERNAL PROCEDURE DO_UNFIX(ITEMVAR OW;RVAR F1,F2;REFERENCE RCELL GPHCODE);
	BEGIN
	RPTR(EXPRN,VARIABLE) BYEX;
	RPTR(AFXDATA) AD;
	RVAR RGF;
	IF LPMATCH(OW,\(AFFIXED,$ F1, $ F2,BIND BYEX,BIND RGF) ) THEN
		BEGIN
		DENYF(OW,_FACT_);
		AD←AFXDGET(F1,F2,BYEX,FALSE);
		IF RGF=RIGIDLY THEN
			BEGIN
			IF AFXDATA:T[AD]=BYEX THEN
				BYEX←AFXDATA:INVT[AD] 
			ELSE
				BYEX←AFXDATA:T[AD];
			LPDENY(OW,\(AFFIXED,$ F2, $ F1,BYEX, RIGIDLY) );
			REMCALC(OW,F1,AFXDATA:C1[AD]);
			REMCALC(OW,F2,AFXDATA:C2[AD]);
			CONSON(NEW_GASSIGN(F2,2,AFXDATA:C2[AD]),GPHCODE);
			END
		ELSE
			BEGIN
			RPTR(ALSODO) ADO;
			REMCALC(OW,F1,AFXDATA:C1[AD]);
			REMCHG(OW,F1,AFXDATA:CHG[AD]);
			CONSON(NEW_ALSODO(F1,2,AFXDATA:CHG[AD]),GPHCODE);
			END;
		CONSON(NEW_GASSIGN(F1,2,AFXDATA:C1[AD]),GPHCODE);
		END;
	END;

INTERNAL PROCEDURE DO_AFFIX(ITEMVAR OW;RVAR F1,F2,BV;REXPR AE;RVAR RGF;
			    REFERENCE RCELL GPHCODE);
	BEGIN
	RANY ASTN;
	RPTR(TRANS) T;
	RPTR(AFXDATA) AD;
	RPTR(VARIABLE) BVV;
	RPTR(BLOCK) BID;
	RPTR(ASSIGNMENT) ASG;

	DO_UNFIX(OW,F1,F2,GPHCODE);
	AD←AFXDGET(F1,F2,BV,TRUE);

	IF AE=NULL_RECORD THEN 
		AE←NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
	           LIST2(NEW_EXPRN(TRANS_DTYPE,TINVRT_OP,CONS(F2,NULL_RECORD)),F1));
			! FTOF(F2,F1);
	VCHANGE(BV,EVALEXPR(AE,OW),OW);

	BID←VARIABLE:BLK[AFXDATA:YOUNGEST[AD]];
	LPASRT(OW,\(AFFIXED, $ F1, $ F2, $ BV, $ RGF));
	IF AFXDATA:C1[AD]=NULL_RECORD THEN
		BEGIN
		AFXDATA:C1[AD]←ASGLBL(NEW_LBL(ANY,CLCLAB_DTYPE,BID),
				BLDCALC(OW,NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
						  LIST2(F2,BV) ),BID));
		END;
	CONSON(NEW_GASSIGN(F1,1,AFXDATA:C1[AD]),GPHCODE);
	ADDCALC(OW,F1,AFXDATA:C1[AD]);
	IF RGF=RIGIDLY THEN
		BEGIN
		IF AFXDATA:INVT[AD]=NULL_RECORD THEN
			BEGIN
			AFXDATA:INVT[AD]←NEW_EXPRN(TRANS_DTYPE,
						   TINVRT_OP,CONS(BV,NULL_RECORD));
			AFXDATA:C2[AD]←ASGLBL(NEW_LBL(ANY,CLCLAB_DTYPE,BID),
					BLDCALC(OW,NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
					   LIST2(F1,AFXDATA:INVT[AD])),BID));
			END;
		CONSON(NEW_GASSIGN(F2,1,AFXDATA:C2[AD]),GPHCODE);
		LPASRT(OW,\(AFFIXED, $ F2, $ F1, $ AFXDATA:INVT[AD], RIGIDLY));
		ADDCALC(OW,F2,AFXDATA:C2[AD]);
		END
	ELSE
		BEGIN
		RPTR(ALSODO) ADO;
		IF AFXDATA:CHG[AD]=NULL_RECORD THEN
			BEGIN
			RVAR FF2; ! to get around a SAIL lossage;
			RPTR(ASSIGNMENT) ASG;
			FF2←F2;
			ASG←NEW_RECORD(ASSIGNMENT);
			ASSIGNMENT:VAR[ASG]←BV;
			ASSIGNMENT:VAL[ASG]←NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
			           LIST2(NEW_EXPRN(TRANS_DTYPE,TINVRT_OP,
						   CONS(FF2,NULL_RECORD)),
								VNEWTRANS) );
			AFXDATA:CHG[AD]←ASGLBL(NEW_LBL(ANY,CHGLAB_DTYPE,BID),
					       BLDCHG(STMAKE(ASG),BID));
			END;
		ADO←NEW_RECORD(ALSODO);
		ALSODO:VAR[ADO]←F1;ALSODO:OP[ADO]←1;
		ALSODO:CHG[ADO]←AFXDATA:CHG[AD];
		ADDCHG(OW,F1,AFXDATA:CHG[AD]);
		CONSON(ADO,GPHCODE);
		END;
	ASG←NEW_RECORD(ASSIGNMENT);
	ASSIGNMENT:VAR[ASG]←BV;
	ASSIGNMENT:VAL[ASG]←AE;
	CONSON(ASG,GPHCODE);
	END;

! blockdo & sttblk, blkopdo;

RECPROC BLOCKDO(RPTR(STMNT) S);
	BEGIN
	ITEMVAR IW;
	RCELL C;
	RPTR(BLOCK) OCB;
	SIMPLE PROCEDURE OCBDO;CURBLK←OCB;
	CLEANUP OCBDO;

	OCB←CURBLK;
	CURBLK←STMNT:SEMANTICS[S];
	C←BLOCK:CODE[CURBLK];
	IW←STMNT:IW[S];
	WHILE C≠NULL_RECORD DO
		BEGIN
		INTEGER ST;
		ST←RECTYPE(CELL:CAR[C]);
		IF ST=LOC(STMNT) THEN
			BEGIN
			STINTERP(CELL:CAR[C]);
			IW←STMNT:OW[CELL:CAR[C]];
			END
		ELSE IF ST=LOC(PVL) THEN
			PVLDO(PVL:VL[CELL:CAR[C]],IW)
		ELSE IF ST=LOC(VARIABLE) THEN
			BEGIN
			END
		ELSE IF ST=LOC(DBD) THEN
			WLDDMP(DBD:WLD[CELL:CAR[C]])
		ELSE IF ST=LOC(NW) THEN
			BEGIN
			END
		ELSE
			BEGIN
			USERERR(1,1,"FUNNY BLOCK ELEMENT");
			END;
		C←CELL:CDR[C];
		END;
	END;

INTERNAL RPTR(BLOCK) PROCEDURE STTBLK(RANY S);
	BEGIN
	RPTR(BLOCK) B;
	IF RECTYPE(S)≠LOC(BLOCK) THEN
		BEGIN
		B←NEW_RECORD(BLOCK);
		BLOCK:CODE[B]←CONS(S,NULL_RECORD);
		RETURN(STMAKE(B));
		END;
	RETURN(S);
	END;

PROCEDURE BLKOPDO(ITEMVAR W;INTEGER OP);
	BEGIN
	RCELL C;
	CASE OP OF
		BEGIN

[ENTERBLOCK]	BEGIN
                C←BLOCK:CLCS[CURBLK];
                WHILE C≠NULL_RECORD DO
                        MK_CALC(W,LLOP(C));
		END;

[LEAVEBLOCK]	BEGIN
                C←BLOCK:CLCS[CURBLK];
                WHILE C≠NULL_RECORD DO
                        KILLCALC(W,LLOP(C));
                C←BLOCK:ALSOS[CURBLK];
                WHILE C≠NULL_RECORD DO
                        KILLCHG(W,LLOP(C));
                C←BLOCK:VARS[CURBLK];
                WHILE C≠NULL_RECORD DO
                        KILLVAR(W,LLOP(C));
		END;

[0]		END;
	END;
! Cobdo;

RECPROC COBDO(RPTR(STMNT) S);
	BEGIN
	RCELL C;
	BOOLEAN FLAG;
	RPTR(STMNT) SS;
	RPTR(FACT) F;
	C←COBLOCK:CODE[CHKREC(STMNT:SEMANTICS[S],LOC(COBLOCK))];
	FLAG←FALSE;
	WHILE C≠NULL_RECORD DO
		BEGIN
		SS←STMCHK(CELL:CAR[C]);
		CPYWLD(STMNT:IW[S],STMNT:IW[SS]);
		STINTERP(SS);
		IF FLAG THEN
			!  RF - added third argument to this call;
			MERGEIN(STMNT:OW[SS],STMNT:OW[S],STMNT:OW[SS])
		ELSE
			BEGIN
			FLAG←TRUE;
			CPYWLD(STMNT:OW[SS],STMNT:OW[S]);
			END;
		C←CELL:CDR[C];
		END;
	IF ¬FLAG THEN
		CPYWLD(STMNT:IW[S],STMNT:OW[S]);
	∀ | GEN_FACTS(F,STMNT:OW[S]) DO
		FLUENT_CHECK(STMNT:OW[S],F);
	END;

! loopbdo;

RECPROC LOOPBDO(RPTR(STMNT) S);
	BEGIN
	CALL_ALERT(STMNT:IW[S]);
	STINTERP(S);
	CHECK_GUARDS(STMNT:IW[S],STMNT:OW[S]);
	END;

! statement interpreter: stinterp (owdo, iwcopy);

INTERNAL RECPROC STINTERP(RPTR(STMNT) S);
	BEGIN
        !  Takes the statement S and interprets what it would do to
        the world.  The worlds associated with S are actually
        modified;
	INTEGER STYP;
	ITEMVAR IW,OW;
	RSSS SS;
	RPTR(STMNT) S1,S2;
	LABEL XIT,YETMORE;

	PROCEDURE OWDO;
		CPYWLD(IW,OW);

	SIMPLE PROCEDURE IWCOPY(RPTR(STMNT) SX);
		CPYWLD(IW,STMNT:IW[SX]);

	IF S=NULL_RECORD THEN 
		RETURN;

	IF RECTYPE(S) ≠ LOC(STMNT)
	    THEN BEGIN  ! Added by RF;
	    USERERR(1,1,"STINTERP:  Not a statement");
	    RETURN;
	    END;

	IF ¬UNBOUND(STMNT:PRC[S]) THEN
		BEGIN
		DEFINE PREDICT_EFFECTS_REC "[]" = "RPEFCT";
		EXTERNAL RANY PREDICT_EFFECTS_REC;
		! defined in RHTREC;
		REC_RESUME(STMNT:PRC[S],PREDICT_EFFECTS_REC);
		RETURN;
		END;

	SS←STMNT:SEMANTICS[S];
	STYP←RECTYPE(SS);

	IF STITRC LAND '1 THEN
		PRINT(CRLF&"STATEMENT TYPE =",CVOS(STYP));
	IF STITRC LAND '2 THEN
		BEGIN
		PRINT(CRLF&"STATEMENT RECORD =");
		ALPRIN(S);
		END;
	IF SS=NULL_RECORD THEN 
		BEGIN
		OWDO; ! null semantics changes nothing;
		RETURN;
		END;

	IW←STMNT:IW[S];
	OW←STMNT:OW[S];
	
	IF STYP=LOC(BLOCK) THEN
		BLOCKDO(S)
	ELSE IF STYP=LOC(ASSIGNMENT) THEN
		BEGIN
		OWDO;
		VCHANGE(ASSIGNMENT:VAR[SS],
			EVALEXPR(ASSIGNMENT:VAL[SS],OW),OW);
		! note that this is OW now (so side effects happen);
		END
	ELSE IF STYP=LOC(GASSIGN) THEN
		BEGIN
		OWDO;
		INVALIDATE(GASSIGN:VAR[SS],OW);
		CASE GASSIGN:OP[SS] OF
			BEGIN
		[1]	ADDCALC(OW,GASSIGN:VAR[SS],GASSIGN:CLC[SS]);
		[2]	REMCALC(OW,GASSIGN:VAR[SS],GASSIGN:CLC[SS]);
		[3]	USERERR(1,1,"ONLY CALC TEMPROARILY MISSING");
		[0]	USERERR(1,1,"ILLEGAL GRAPH ASSIGNMENT OP")
			END;
		END
	ELSE IF STYP=LOC(IFF) THEN
		BEGIN
		! here need code to handle conditional;
		S1←STMCHK(IFF:THN[SS]);
		S2←STMCHK(IFF:ELS[SS]);
		IWCOPY(S1);
		IWCOPY(S2);
		STINTERP(S1);
		STINTERP(S2);
		ANDWLD(STMNT:OW[S1],STMNT:OW[S2],OW);
		END
	ELSE IF STYP=LOC(COBLOCK) THEN
		BEGIN
		COBDO(S);
		END
	ELSE IF STYP=LOC(WHIL) THEN
		BEGIN
		S1←WHIL:BODY[SS];
		IF S1≠NULL_RECORD THEN
			BEGIN
			S1←STMCHK(S1);
			IWCOPY(S1);
			LOOPBDO(S1);
			ANDWLD(STMNT:OW[S1],IW,OW);
			END
		ELSE
			OWDO;
		END
	ELSE IF STYP=LOC(FORR) THEN
		BEGIN  !  Added by RF;
		S1←FORR:BODY[SS];
		IF S1≠NULL_RECORD THEN
			BEGIN
			S1←STMCHK(S1);
			IWCOPY(S1);
			LOOPBDO(S1);
			ANDWLD(STMNT:OW[S1],IW,OW);
			END
		ELSE
			OWDO;
		END
	ELSE IF STYP=LOC(ASSERT) THEN
		BEGIN
		OWDO;
		ASRTIT(ASSERT:FACT[SS],IW,ASSERT:WLD[SS]);
		END
	ELSE IF STYP=LOC(DENY) THEN
		BEGIN
		OWDO;
		DENYIT(DENY:FACT[SS],IW,DENY:WLD[SS]);
		END
	ELSE IF STYP=LOC(AFFIX) THEN
		BEGIN
		OWDO;
		AFFIX:GPHCODE[SS]←NULL_RECORD;
		DO_AFFIX(OW,AFFIX:FRAME1[SS],AFFIX:FRAME2[SS],AFFIX:BYVAR[SS],
			 AFFIX:ATEXP[SS],AFFIX:RIGID[SS],AFFIX:GPHCODE[SS]);
		END
	ELSE IF STYP=LOC(UNFIX) THEN
		BEGIN
		OWDO;UNFIX:GPHCODE[SS]←NULL_RECORD;
		DO_UNFIX(OW,UNFIX:FRAME1[SS],UNFIX:FRAME2[SS],UNFIX:GPHCODE[SS]);
		END
	ELSE IF STYP=LOC(BLKOP) THEN
		BEGIN
		OWDO;
		BLKOPDO(OW,BLKOP:OP[SS]);
		END
	ELSE IF STYP=LOC(NW) THEN
		OWDO
	ELSE IF STYP = LOC(MOVE$) THEN
		BEGIN "move"
		DOMOVE(S);
		END "move"
	ELSE IF STYP = LOC(OPERATE) THEN
		BEGIN "operate"
		DOOPERATE(S);
		END "operate"
	ELSE
		GO TO YETMORE;	! to get around SAILs parse stack limits 
				  without using /R ;
	GO TO XIT;

YETMORE:IF STYP = LOC(COMMNT) OR STYP = LOC(CENTER) OR STYP = LOC(STOP) 
	OR STYP = LOC(PRNT) OR STYP = LOC(PAUSE) OR STYP = LOC(ABORT) THEN
		BEGIN "others"  !  Added by RF, added to by ARG;
		OWDO;
		END "others"
	ELSE IF STYP = LOC(ALSODO) THEN
		BEGIN "alsodo"  !  Added by RF;
		OWDO;	
		ADDCHG(OW,ALSODO:VAR[SS],ALSODO:CHG[SS]);
		END "alsodo"
	ELSE IF STYP = LOC(CMON) THEN
		BEGIN  "cmon"  ! Added by RF;
		S1 ← STMCHK(CMON:CONCLUSION[SS]);
		IWCOPY(S1);
		STINTERP(S1);
		OWDO;  ! Ignore any effects the CMON may have;
		END "cmon"
	ELSE IF STYP = LOC(EVDO) THEN
		BEGIN  "evdo"  ! Added by RF;
		OWDO;  ! Temporarily does nothing;
		END "evdo"
	ELSE IF STYP = LOC(PROG) THEN	!  added by RF;
		STINTERP(PROG:CODE[SS])
	ELSE
		BEGIN
		PRINT(CRLF&"***");
		ALPRIN(SS);
		USERERR(1,1," STINTERP GIVEN A STATEMENT TYPE IT CANNOT HANDLE");
		END;
XIT:	END;

ifcr false thenc ! proc_form interpreter:  apfrm, apfrm2;

INTERNAL RECPROC APFRM(RPTR(PROC_FORM) PF;RCELL VL);
	BEGIN
	RCELL PFFPL;
	PFFPL←PROC_FORM:FPS[PF];
	WHILE PFFPL≠NULL_RECORD ∧ VL≠NULL_RECORD DO
		BEGIN
		VCELL:VAL[CELL:CAR[PFFPL]]←CELL:CAR[VL];
		PFFPL←CELL:CDR[PFFPL];
		VL←CELL:CDR[VL];
		END;
	STINTERP(PROC_FORM:S[PF]);
	END;

INTERNAL RECPROC APFRM2(RPTR(PROC_FORM) PF;RPTR(VALU$) V1,V2);
	BEGIN
	RCELL PFFPL;
	RPTR(VALU$) V;
	PFFPL←PROC_FORM:FPS[PF];
	FOR V←V1,V2 DO
		BEGIN
		IF PFFPL=NULL_RECORD THEN DONE;
		VCELL:VAL[CELL:CAR[PFFPL]]←V;
		PFFPL←CELL:CDR[PFFPL];
		END;
	STINTERP(PROC_FORM:S[PF]);
	END;

endc
! test program;

IFCR FALSE THENC
INTERNAL PROCEDURE WMTEST;
     WHILE TRUE DO
	BEGIN
	REQUIRE "GOBBLE.HDR[HAL,HE]" SOURCE_FILE;
	INTEGER NF,F,D;
	RCELL SE;
	RANY ST;
	RPTR(STMNT) BS;
	GETFORMAT(F,D);
	SETFORMAT(0,3);
	SE←READ;
	ST←GROVEL(SE);
	BS←STTBLK(ST);
	NF←TRUE;
	WLDASG(BS,CURWLD,CURWLD,NF);
	ALPRIN(BS);
	PRINT(CRLF);
	STINTERP(BS);
	SETFORMAT(F,D);
	END;
ENDC

END $$PRGID;